Some usefull VBA snippets for Microsoft Outlook

Ignore Thread

' Create a rule filtering out mail with the current subject to a hardcoded folder. Only works for MailItems and if only one Mail is selected.
' If zero or more than one mails are selected user will get an error message.
' If you place this as a button to the Quick Access toolbar you can use <alt>-<3> (or a different number, depending on the position in the toolbar)
' to invoke this script.
Sub IngoreThread()
    Dim olExplorer As Outlook.Explorer
    Dim oMailItem As MailItem
    Dim olSelection As Selection
    
    
    Set olExplorer = Application.ActiveExplorer
    ' get currently selected items
    Set olSelection = olExplorer.Selection
    
    ' If less or more than one items are selected, display an error and exit
    If olSelection.Count <> 1 Then
        MsgBox "Error: Please select exactly one mail", vbCritical
        Exit Sub
    End If
    Set oMailItem = olSelection.Item(1)
    createThreadIgnoreRule (oMailItem.subject)
End Sub

' Create a rule for filtering out a certain mailthread. The subject does not need to be sanitized before.
Sub createThreadIgnoreRule(subject As String)
    Dim colRules As Outlook.Rules
    Dim oRule As Outlook.Rule
    Dim colRuleActions As Outlook.RuleActions
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
    Dim oFromCondition As Outlook.ToOrFromRuleCondition
    Dim oSubject As Outlook.TextRuleCondition
    Dim oInbox As Outlook.Folder
    Dim oMoveTarget As Outlook.Folder
    Dim sanitizedSubject As String
    
    ' sanitize the subject. If it is already calling this function still doesn't matter as the subject just will not be changed then.
    sanitizedSubject = sanitizeSubject(subject)
    
    ' check if we have already a rule for this subject
    If isRuleExisting(sanitizedSubject) = True Then
        ' Rule already exists, exit
        Debug.Print ("Rule for """ & sanitizedSubject & """ is already existing, not creating it again")
        Exit Sub
    End If
    ' This will take some time. Show a small message box to inform the user.
    ignoreThreadProgress.Show
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    ' The target for mails. You can change this to whatever you want. The folder is not autocreated.
    Set oMoveTarget = oInbox.Folders("ruletest")
    ' Get all current rules
    Set colRules = Application.Session.DefaultStore.GetRules()
    ' Create a new rule for the subject. All rules start with "com.nomike.ignorethread." (think java packages here) followed by the
    ' sanitized subject an underscore and the current date. This way rules are easy to identify and a could be deleted after a defined amout of time
    Set oRule = colRules.Create("com.nomike.ignorethread." & sanitizedSubject & "_" & Format(Now, "yyyy-MM-dd"), olRuleReceive)
    
    ' Set action of rule to move mails to a folder
    Set oMoveRuleAction = oRule.Actions.MoveToFolder
    
    ' Configure move action
    With oMoveRuleAction
        .Enabled = True
        .Folder = oMoveTarget
    End With
    
    ' Set confition of the rule to match a certain subject
    Set oSubject = oRule.Conditions.subject
    
    ' Configure subject condition
    With oSubject
        .Enabled = True
        .Text = Array(sanitizedSubject)
    End With
    ' Save rule. This usually takes some time (>= 10 seconds)
    colRules.Save
    ' Hide message box
    ignoreThreadProgress.Hide
    ' Execute rule on inbox
    oRule.Execute (showProgress = True)
End Sub

' Check if a rule starting for the sanitized subject is already existing
Function isRuleExisting(sanitizedSubject As String) As Boolean
    Dim colRules As Outlook.Rules
    Dim oRule As Outlook.Rule
    
    ' get all rules and loop over them
    Set colRules = Application.Session.DefaultStore.GetRules()
    For i = colRules.Count To 1 Step -1
        Set oRule = colRules.Item(i)
        ' check if rule is existing
        If (InStr(oRule.Name, "com.nomike.ignorethread." & sanitizedSubject) = 1) Then
            'rule is existing, return true
            isRuleExisting = True
            Exit Function
        End If
    Next
    ' rule was not found, return false
    isRuleExisting = False
    Exit Function
End Function

' Remove common prefixes from subject (e.g. "Re: ", "Fwd: ", etc.)
' As localized versions of Outlook use different prefixes, you might need to adapt the subjectPrefixes Array. Currently it should work for english and german.
Function sanitizeSubject(subject As String) As String
    Dim changed As Boolean
    changed = True
    Dim subjectPrefixes As Variant
    ' Add new prefixes here if they apply to you. The trailing whitespace is not mandatory as the subject is trimmed anyway later.
    subjectPrefixes = Array("FWD: ", "RE: ", "FW: ", "WG: ", "AW: ", "WE: ")
    
    ' Execute this part as long as something is changed to also deal with "Re: Fwd: AW: Hello world" subjects properly
    While changed = True
        changed = False
        ' Loop over all prefixes
        For Each Prefix In subjectPrefixes
            ' Check if subject starts with prefix, convert strings to uppercase for conversion to make it case insensitive
            If (InStr(UCase(subject), UCase(Prefix)) = 1) Then
                changed = True
                ' cut out the prefix and additionally trim the subject to remove excess whitespace
                subject = Trim(Mid(subject, Len(Prefix) + 1))
            End If
        Next
    Wend
    ' return the sanitized subject
    sanitizeSubject = subject
    Exit Function
End Function

Accept Meeting Invitations

Sub AcceptMeetings()
    Dim myExplorer As Outlook.explorer
    Dim mySelection As selection
    Dim myMailItem As Object
    
    Dim myMessageDate As Date
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myArchive As Outlook.MAPIFolder
    Dim myMessageYear As Integer
    Dim myMeetingItem As Outlook.MeetingItem
    
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myArchive = myInbox.Folders("Archive")
    Set myExplorer = Application.activeExplorer
    Set mySelection = myExplorer.selection
    For i = 1 To mySelection.Count
        Set myMailItem = mySelection.Item(i)
        Debug.Print TypeName(myMailItem)
        If TypeName(myMailItem) = "MeetingItem" Then
            Dim myAppointmentItem As Outlook.AppointmentItem
            Set myAppointmentItem = myMailItem.GetAssociatedAppointment(True)
            myAppointmentItem.Respond olMeetingAccepted, True
            myMailItem.Delete
            DoEvents
        End If
    Next i
End Sub

Archive Mails

Sub ArchiveMail()
    Dim myExplorer As Outlook.explorer
    Dim mySelection As selection
    Dim myMailItem As MailItem
    Dim myMessageDate As Date
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myArchive As Outlook.MAPIFolder
    Dim myMessageYear As Integer
    
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myArchive = myInbox.Folders("Archive")
    Set myExplorer = Application.activeExplorer
    Set mySelection = myExplorer.selection
    
    For i = 1 To mySelection.Count
        Set myMailItem = mySelection.Item(i)
        myMessageDate = myMailItem.CreationTime
        myMessageYear = Year(myMessageDate)
        Debug.Print myMessageYear
        Debug.Print myMailItem.SenderName
        moveMailToArchive myMailItem, myArchive
    Next i
End Sub

Sub moveMailToArchive(myMailItem As Outlook.MailItem, myArchiveFolder As
Outlook.MAPIFolder)
    Dim myYearFolder As Outlook.MAPIFolder
    On Error Resume Next
        Set myYearFolder =
myArchiveFolder.Folders(Trim(Str(Year(myMailItem.CreationTime))))
        If myYearFolder Is Nothing Then
            Set myYearFolder =
myArchiveFolder.Folders.Add(Year(myMailItem.CreationTime))
        End If
        myMailItem.UnRead = False
        myMailItem.Move myYearFolder
End Sub

Move phising test mails

Sub MoveToVBTestFolder(Item As Outlook.MailItem)
    Dim ns As Outlook.NameSpace
    Dim destFolder As Outlook.Folder

    Set ns = Application.GetNamespace("MAPI")
    Set destFolder = ns.Folders("nomike.postmann@paysafe.com").Folders("vbtest")

    If Not destFolder Is Nothing Then
        Item.Move destFolder
    Else
        MsgBox "Destination folder not found!", vbExclamation
    End If
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim ns As Outlook.NameSpace
    Dim itm As Object
    Dim arr() As String
    Dim i As Integer

    Set ns = Application.GetNamespace("MAPI")
    arr = Split(EntryIDCollection, ",")

    For i = LBound(arr) To UBound(arr)
        Set itm = ns.GetItemFromID(arr(i))
        If TypeOf itm Is Outlook.MailItem Then
            If InStr(itm.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E"), Chr(88) & Chr(45) & Chr(80) & Chr(72) & Chr(73) & Chr(83) & Chr(72) & Chr(84) & Chr(69) & Chr(83) & Chr(84)) > 0 Then
                MoveToVBTestFolder itm
            End If
        End If
    Next
End Sub